home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / conditional.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  3KB  |  185 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.  
  9.     conditional.c
  10.  
  11.     conditionals
  12. */
  13.  
  14. #include "include.h"
  15.  
  16. object Sotherwise;
  17.  
  18. Fif(form)
  19. object form;
  20. {
  21.     object *top = vs_top;
  22.  
  23.     if (endp(form) || endp(MMcdr(form)))
  24.         FEtoo_few_argumentsF(form);
  25.     if (!endp(MMcddr(form)) && !endp(MMcdddr(form)))
  26.         FEtoo_many_argumentsF(form);
  27.     eval(MMcar(form));
  28.     if (vs_base[0] == Cnil)
  29.         if (endp(MMcddr(form))) {
  30.             vs_top = vs_base = top;
  31.             vs_push(Cnil);
  32.         } else {
  33.             vs_top = top;
  34.             eval(MMcaddr(form));
  35.         }
  36.     else {
  37.         vs_top = top;
  38.         eval(MMcadr(form));
  39.     }
  40. }
  41.  
  42. Fcond(args)
  43. object args;
  44. {
  45.     object *top = vs_top;
  46.     object clause;
  47.     object conseq;
  48.  
  49.     while (!endp(args)) {
  50.         clause = MMcar(args);
  51.         if (type_of(clause) != t_cons)
  52.             FEerror("~S is an illegal COND clause.",1,clause);
  53.         eval(MMcar(clause));
  54.         if (vs_base[0] != Cnil) {
  55.             conseq = MMcdr(clause);
  56.             if (endp(conseq)) {
  57.                 vs_top = vs_base+1;
  58.                 return;
  59.             }
  60.             while (!endp(conseq)) {
  61.                 vs_top = top;
  62.                 eval(MMcar(conseq));
  63.                 conseq = MMcdr(conseq);
  64.             }
  65.             return;
  66.         }
  67.         vs_top = top;
  68.         args = MMcdr(args);
  69.     }
  70.     vs_base = vs_top = top;
  71.     vs_push(Cnil);
  72. }
  73.  
  74. Fcase(arg)
  75. object arg;
  76. {
  77.     object *top = vs_top;
  78.     object clause;
  79.     object key;
  80.     object conseq;
  81.  
  82.     if (endp(arg))
  83.         FEtoo_few_argumentsF(arg);
  84.     eval(MMcar(arg));
  85.     vs_top = top;
  86.     vs_push(vs_base[0]);
  87.     arg = MMcdr(arg);
  88.     while (!endp(arg)) {
  89.         clause = MMcar(arg);
  90.         if (type_of(clause) != t_cons)
  91.             FEerror("~S is an illegal CASE clause.",1,clause);
  92.         key = MMcar(clause);
  93.         conseq = MMcdr(clause);
  94.         if (type_of(key) == t_cons)
  95.             do {
  96.                 if (eql(MMcar(key),top[0]))
  97.                     goto FOUND;
  98.                 key = MMcdr(key);
  99.             } while (!endp(key));
  100.         else if (key == Cnil)
  101.             ;
  102.         else if (key == Ct || key == Sotherwise || eql(key,top[0]))
  103.             goto FOUND;
  104.         arg = MMcdr(arg);
  105.     }
  106.     vs_base = vs_top = top;
  107.     vs_push(Cnil);
  108.     return;
  109.  
  110. FOUND:
  111.     if (endp(conseq)) {
  112.         vs_base = vs_top = top;
  113.         vs_push(Cnil);
  114.     } else
  115.          do {
  116.             vs_top = top;
  117.             eval(MMcar(conseq));
  118.             conseq = MMcdr(conseq);
  119.         } while (!endp(conseq));
  120.     return;
  121. }
  122.  
  123. Fwhen(form)
  124. object form;
  125. {
  126.     object *top = vs_top;
  127.  
  128.     if (endp(form))
  129.         FEtoo_few_argumentsF(form);
  130.     eval(MMcar(form));
  131.     if (vs_base[0] == Cnil) {
  132.         vs_base = vs_top = top;
  133.         vs_push(Cnil);
  134.     } else {
  135.         form = MMcdr(form);
  136.         if (endp(form)) {
  137.             vs_base = vs_top = top;
  138.             vs_push(Cnil);
  139.         } else
  140.             do {
  141.                 vs_top = top;
  142.                 eval(MMcar(form));
  143.                 form = MMcdr(form);
  144.             } while (!endp(form));
  145.     }
  146. }
  147.  
  148. Funless(form)
  149. object form;
  150. {
  151.     object *top = vs_top;
  152.  
  153.     if (endp(form))
  154.         FEtoo_few_argumentsF(form);
  155.     eval(MMcar(form));
  156.     if (vs_base[0] == Cnil) {
  157.         vs_top = top;
  158.         form = MMcdr(form);
  159.         if (endp(form)) {
  160.             vs_base = vs_top = top;
  161.             vs_push(Cnil);
  162.         } else
  163.             do {
  164.                 vs_top = top;
  165.                 eval(MMcar(form));
  166.                 form = MMcdr(form);
  167.             } while (!endp(form));
  168.     } else {
  169.         vs_base = vs_top = top;
  170.         vs_push(Cnil);
  171.     }
  172. }
  173.  
  174. init_conditional()
  175. {
  176.     make_special_form("IF",Fif);
  177.     make_special_form("COND",Fcond);
  178.     make_special_form("CASE",Fcase);
  179.     make_special_form("WHEN",Fwhen);
  180.     make_special_form("UNLESS",Funless);
  181.  
  182.     Sotherwise = make_ordinary("OTHERWISE");
  183.     enter_mark_origin(&Sotherwise);
  184. }
  185.